home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / swags-z / sorting.swg / 0037_Classic QSORT Routine.pas < prev    next >
Pascal/Delphi Source File  |  1993-09-26  |  4KB  |  112 lines
  1. (*
  2. From: ROLAND WODITSCH
  3. Subj: QUICK SORT
  4. *)
  5.  
  6. UNIT QSort5;
  7.  
  8. INTERFACE
  9. TYPE OrdFunction = FUNCTION(VAR a,b):BOOLEAN;
  10.  
  11. PROCEDURE Sortiere(VAR SortArray; Elementgroesse,LoIndex,HiIndex: word;
  12.                    SortKleiner: OrdFunction; von,bis:word);
  13.  
  14. {       SortArray  field to sort                                          }
  15. {       LoIndex    the lowest,                                            }
  16. {       HiIndex    the highest fieldindex like in the fielddeklarartion   }
  17. {       OrdAdr     the funktion from typ OrdFunction (s.o.)               }
  18. {       von, bis   the sortarea                                           }
  19.  
  20. {     befor calling (not befor bind!) your have to define a               }
  21. {     asymmetric  order funktion :                                        }
  22. {     function IrgendEinName(VAR x,y : TypDerFeldElemente):boolean        }
  23. {     example: (*$F+*) function kleiner(VAR x,y: integer):boolean;        }
  24. {                        begin kleiner:=x<y end;  (*$F-*)                 }
  25. {               not:  kleiner:=x<=y  (not asymmetric!)                    }
  26. {     attention: x and y must be VAR-parameters !!!                       }
  27.  
  28.  
  29.  
  30. IMPLEMENTATION
  31.  
  32. procedure Sortiere(VAR SortArray; ElementGroesse,LoIndex,HiIndex: word;
  33.                        SortKleiner:OrdFunction; von,bis:word);
  34.   type ArrayPtr = ^Byte;
  35.   var Mitte, i0, j0, m0 : ArrayPtr;
  36.  
  37.   procedure Swap(VAR x,y; size : word);
  38.     begin
  39.      INLINE ($1E/$C4/$B6/X/$C5/$BE/Y/$8B/$8E/SIZE/$E3/$0C/$26/$8A/$04/
  40.              $86/$05/$26/$88/$04/$46/$47/$E2/$F4/$1F)
  41.     end;
  42.  
  43.   function Element(i : word) : ArrayPtr;
  44.     begin
  45.       Element:=ptr(seg(SortArray),ofs(SortArray)+i*ElementGroesse)
  46.     end;
  47.  
  48.   procedure inc(var index : word; var pointer : ArrayPtr);
  49.     begin
  50.       index:=succ(index);
  51.       pointer:=ptr(seg(pointer^),ofs(pointer^)+ElementGroesse)
  52.     end;
  53.  
  54.   procedure dec(var index : word; var pointer : ArrayPtr);
  55.     begin
  56.       index:=pred(index);
  57.       pointer:=ptr(seg(pointer^),ofs(pointer^)-ElementGroesse)
  58.     end;
  59.  
  60.   procedure E_Sort(von, bis : word);
  61.     label EXIT;
  62.     var i, j : word;
  63.     begin
  64.       if bis<=von then goto EXIT;
  65.       i:=von; i0:=Element(i);
  66.       while i<bis do begin
  67.         m0:=i0; j:=i; j0:=i0; inc(j,j0);
  68.         while j<=bis do begin
  69.           if SortKleiner(j0^,m0^) then m0:=j0;
  70.           inc(j,j0)
  71.         end; (* WHILE j *)
  72.         if m0<>i0 then Swap(i0^,m0^,ElementGroesse);
  73.         inc(i,i0)
  74.       end; (* WHILE i *)
  75.       EXIT:
  76.     end; (* E_Sort *)
  77.  
  78.   procedure Sort(von, bis : word);  (* Rekursive Quicksort *)
  79.     label EXIT;
  80.     var i, j : word;
  81.     begin
  82.       if bis-von<6 then begin E_Sort(von,bis); goto EXIT end;
  83.       i:=von; j:=bis; m0:=Element((i+j) SHR 1);
  84.       move(m0^,Mitte^,ElementGroesse); i0:=Element(i); j0:=Element(j);
  85.       while i<=j do begin
  86.         while SortKleiner(i0^,Mitte^) do inc(i,i0);
  87.         while SortKleiner(Mitte^,j0^) do dec(j,j0);
  88.         if i<=j then begin
  89.           if i<>j then Swap(i0^,j0^,ElementGroesse);
  90.           inc(i,i0); dec(j,j0)
  91.         end (* if i<=j *)
  92.       end; (* while i<=j *)
  93.       if bis-i<j-von then begin
  94.                        if i<bis then Sort(i,bis);
  95.                        if von<j then Sort(von,j)
  96.                        end
  97.                      else begin
  98.                        if von<j then Sort(von,j);
  99.                        if i<bis then Sort(i,bis)
  100.                        end;
  101.       EXIT:
  102.     end; (* Sort *)
  103.  
  104.   begin
  105.     getmem(Mitte,ElementGroesse);
  106.     Sort(von-LoIndex,bis-LoIndex);
  107.     freemem(Mitte,ElementGroesse)
  108.   end; (* Sort *)
  109.  
  110. END. (* IMPLEMENTATION OF UNIT QSORT *)
  111.  
  112.